home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Internet Surfer: Getting Started
/
Internet Surfer - Getting Started (Wayzata Technology)(7231)(1995).bin
/
pc
/
mac
/
bonus
/
peter_le
/
dehqx-20
/
readhqx.p
< prev
next >
Wrap
Text File
|
1991-08-23
|
13KB
|
558 lines
unit ReadHQX;
{ DeHQX v2.0.0 ⌐ Peter Lewis, Aug 1991 }
interface
uses
MyTypes, MyFileSystem, AppGlobals, MyUtilities, CRCs, Preferences, Displays, HQXLists, MyMainLoop, SmallEvents;
type
hqxInfo = record
name: str63;
wdrn: integer;
dirID: longInt;
c, t: OSType;
flags: integer;
dlen, rlen: longInt;
end;
var
crc: integer;
procedure InitReadHQX;
procedure FinishReadHQX;
procedure ReInitReadHQX;
function OpenHQX: OSErr;
procedure FinishHQX;
procedure CreateFolder (var ovrn: integer; var odirID: longInt);
function ReadByte (var b: byte): OSErr;
function ReadColon: OSErr;
function ReadInteger (var b: integer): OSErr;
function ReadLong (var b: longInt): OSErr;
function ReadOSType (var t: OSType): OSErr;
function ReadString (var s: str255): OSErr;
function ReadHeader (var hi: hqxInfo; wp: windowPtr): OSErr;
implementation
const
buffer_slop = 70; { Amount of lookahead required to scan for beginstr }
buffer_size = 16384;
dud_byte = 255;
cr = 13;
lf = 10;
spc = 32;
bad_filern = -32000;
var
thevalue: packed array[0..255] of byte;
state: 0..6;
value: byte;
repeating: boolean;
repvalue: byte;
repcount: integer;
startstr, beginstr: str63;
blen: integer; { blen=length(beginstr) }
read_hqx_byte: longInt; { incremented for each read hqx byte, if it exceeds buffer_slop }
{ I will accept the file for deletion. }
infile: integer;
buffer: packed array[0..buffer_size] of byte;
buffer_len: integer;
finished_files: boolean;
default_ovrn: integer;
default_odirID: longInt;
create_folder: boolean;
procedure CreateFolder (var ovrn: integer; var odirID: longInt);
var
oe: OSErr;
pb: CInfoPBRec;
dirID: longInt;
s: str255;
begin
ovrn := default_ovrn;
odirID := default_odirID;
if create_folder then begin
oe := DirCreate(ovrn, odirID, GetGlobalString(folder_name), dirID);
if oe <> noErr then begin
with pb do begin
s := GetGlobalString(folder_name);
ioNamePtr := @s;
ioVRefNum := ovrn;
ioFDirIndex := 0;
ioDirID := odirID;
oe := PBGetCatInfo(@pb, false);
if oe = noErr then begin
if BAND(ioFlAttrib, $0010) <> 0 then begin
odirID := ioDirID;
end;
end;
end;
end
else
odirID := dirID;
default_odirID := odirID;
create_folder := false;
end;
end;
procedure InitReadHQX;
var
i: integer;
s: str255;
begin
GetIndString(s, hqx_strh_id, 3);
for i := 0 to 255 do
thevalue[i] := dud_byte;
for i := 1 to 64 do begin
thevalue[ord(s[i])] := i - 1;
end;
startstr := GetIndStrSize(sizeof(startstr), hqx_strh_id, 1);
beginstr := GetIndStrSize(sizeof(beginstr), hqx_strh_id, 2);
blen := length(beginstr) - 1;
InitHQXLists;
end;
procedure ReInitReadHQX;
begin
state := 0;
value := 0;
repeating := false;
repcount := 0;
end;
procedure FinishReadHQX;
begin
FinishHQXLists;
end;
function ReadBuffer: OSErr;
{ NOTE: must have buffer_len-buffer_slop<=buffer_pos<=buffer_len }
var
bl: longInt;
oe: OSErr;
bs: integer;
begin
if (buffer_pos = 0) and (buffer_len = buffer_size) then
oe := myErr
else begin
bs := buffer_len - buffer_pos;
if bs > 0 then
BlockMove(@buffer[buffer_pos], @buffer[0], bs);
size_processed := size_processed + buffer_pos;
buffer_pos := 0;
bl := buffer_size - bs;
oe := FSRead(infile, bl, @buffer[bs]);
if oe = eofErr then
oe := noErr;
if bl = 0 then
oe := eofErr;
if oe <> noErr then
bl := 0;
buffer_len := bl + bs;
end;
ReadBuffer := oe;
end;
function OpenEitherHQX: OSErr;
var
oe, ooe: OSErr;
dirID: longInt;
name: str63;
begin
if AnyFilesLeft then begin
GetNextFile(default_ovrn, default_odirID, name, create_folder);
oe := MFSOpenDF(infile, default_ovrn, default_odirID, name, PIn);
if oe = noErr then
oe := ReadBuffer
else
infile := bad_filern;
read_hqx_byte := 0;
end
else
oe := fnfErr;
OpenEitherHQX := oe;
end;
function OpenHQX: OSErr;
begin
buffer_len := 1;
buffer_pos := 1;
finished_files := false;
OpenHQX := OpenEitherHQX
end;
function OpenOtherHQX: OSErr;
var
ooe: OSErr;
begin
if infile <> bad_filern then begin
ooe := FSClose(infile);
infile := bad_filern;
FinishFile(read_hqx_byte > buffer_slop);
{ yick. Its the only way I figure I can safely delete a file, given all the buffering going on }
end;
OpenOtherHQX := OpenEitherHQX;
end;
procedure FinishHQX;
var
ooe: OSErr;
begin
if infile <> bad_filern then
ooe := FSClose(infile);
end;
function FileReadByte (var b: byte): OSErr;
var
oe: OSErr;
begin { Some of this code is expanded inline in other procedures, so be careful modifying it }
if buffer_pos < buffer_len - buffer_slop then begin
b := buffer[buffer_pos];
buffer_pos := buffer_pos + 1;
FileReadByte := noErr;
end
else begin
oe := noErr;
if finished_files then begin
if buffer_pos >= buffer_len then
oe := fnfErr;
end
else begin
while (buffer_pos >= buffer_len - buffer_slop) and (oe = noErr) do
oe := ReadBuffer;
while oe = eofErr do
oe := OpenOtherHQX;
if oe = fnfErr then begin
if buffer_pos < buffer_len then
oe := noErr;
finished_files := true;
end;
end;
if oe = noErr then begin
b := buffer[buffer_pos];
buffer_pos := buffer_pos + 1;
end;
FileReadByte := oe;
end;
end;
function ReadAByte (var b: byte): OSErr;
var
oe: OSErr;
i: integer;
procedure RB;
var
b: byte;
label
1;
begin
if buffer_pos < buffer_len - buffer_slop then begin
b := buffer[buffer_pos];
buffer_pos := buffer_pos + 1;
oe := noErr;
if b <= spc then
goto 1;
value := thevalue[b];
if value = dud_byte then
oe := HqxFormatErr;
end
else begin
oe := FileReadByte(b);
1: { skip <cr>, and check for <cr>--- end of part }
if b <= spc then {short cut most of this expression for the normal case }
if oe = noErr then begin
while (oe = noErr) and (b <= spc) do
oe := FileReadByte(b);
if b = ord(beginstr[1]) then
if prefs.parts_state then
if (buffer[buffer_pos] = ord(beginstr[2])) and (buffer_pos + blen - 2 <= buffer_len) then begin
i := 3;
while (buffer[buffer_pos + i - 2] = ord(beginstr[i])) and (i < blen) do begin
i := i + 1;
end;
if i = blen then begin {skiping headers - waiting for a <cr>---<cr> }
buffer_pos := buffer_pos + i - 2;
repeat
repeat
while (oe = noErr) and (b >= spc) do
oe := FileReadByte(b);
while (oe = noErr) and (b < spc) do
oe := FileReadByte(b);
until (oe <> noErr) or (b = ord('-'));
until (oe <> noErr) or ((buffer[buffer_pos] = b) and (buffer[buffer_pos + 1] = b) and (buffer[buffer_pos + 2] <= spc));
if oe = noErr then
oe := FileReadByte(b); { '-' }
if oe = noErr then
oe := FileReadByte(b); { '-' }
if oe = noErr then
oe := FileReadByte(b); { cr }
if oe = noErr then
oe := FileReadByte(b); { next char }
if oe = noErr then
goto 1;
end; { if i=blen }
end; { if parts_state }
end; { if b<=spc }
if oe = noErr then begin
value := thevalue[b];
if value = dud_byte then
oe := HqxFormatErr;
end;
end;
end;
begin
case state of
0:
begin
RB;
b := BAND(BSL(value, 2), $FF);
if oe = noErr then
RB;
b := BOR(b, BSR(value, 4));
state := 2;
end;
2:
begin
b := BAND(BSL(value, 4), $FF);
RB;
b := BOR(b, BSR(value, 2));
state := 4;
end;
4:
begin
b := BAND(BSL(value, 6), $FF);
RB;
b := BOR(b, value);
state := 0;
end;
otherwise
oe := myErr;
end;
ReadAByte := oe;
end;
function ReadByte (var b: byte): OSErr;
label
1;
var
oe: OSErr;
begin
if repeating then begin
oe := noErr;
repcount := repcount - 1;
repeating := repcount > 0;
b := repvalue;
end
else begin
1:
oe := ReadAByte(b);
if b = $90 then
if oe = noErr then begin
oe := ReadAByte(b);
if oe = noErr then
if b = 0 then
b := $90
else begin
if b < 2 then
goto 1;
repcount := b - 2;
repeating := repcount > 0;
b := repvalue;
end;
end;
end;
CalcCRC(crc, b);
read_hqx_byte := read_hqx_byte + 1;
repvalue := b;
ReadByte := oe;
end;
function ReadColon: OSErr;
var
b: byte;
oe: OSErr;
begin
oe := FileReadByte(b);
if (oe = noErr) and (b = ord('!')) then { slight kludge, beets me why! }
oe := FileReadByte(b);
if (oe = noErr) and (b <> ord(':')) then
oe := hqxFormatErr;
ReadColon := oe;
end;
{$PUSH}
{$R-}
function ReadInteger (var b: integer): OSErr;
var
b1, b2: byte;
oe: OSErr;
begin
oe := ReadByte(b1);
if oe = noErr then
oe := ReadByte(b2);
if oe = noErr then
b := BOR(BSL(b1, 8), b2);
ReadInteger := oe;
end;
function ReadLong (var b: longInt): OSErr;
var
b1, b2, b3, b4: byte;
oe: OSErr;
begin
oe := ReadByte(b1);
if oe = noErr then
oe := ReadByte(b2);
if oe = noErr then
oe := ReadByte(b3);
if oe = noErr then
oe := ReadByte(b4);
if oe = noErr then
b := BOR(BOR(BOR(BSL(b1, 24), BSL(b2, 16)), BSL(b3, 8)), b4);
ReadLong := oe;
end;
{$POP}
function ReadOSType (var t: OSType): OSErr;
begin
ReadOSType := ReadLong(longInt(t));
end;
function ReadString (var s: str255): OSErr;
var
oe: OSErr;
len, ch: byte;
begin
oe := ReadByte(len);
s := '';
while (oe = noErr) and (len > 0) do begin
oe := ReadByte(ch);
s := concat(s, chr(ch));
len := len - 1;
end;
ReadString := oe;
end;
function FindStart (wp: windowPtr): OSErr;
var
oe: OSErr;
b: byte;
dummy_reply: HEReply;
slen, i, cnt: integer;
startchar: byte;
begin
slen := length(startstr);
startchar := ord(startstr[1]);
cnt := 1;
oe := noErr;
while (oe = noErr) do begin
repeat
if buffer_pos < buffer_len - buffer_slop then begin
b := buffer[buffer_pos];
buffer_pos := buffer_pos + 1;
end
else begin
oe := FileReadByte(b);
if oe <> noErr then begin
FindStart := oe;
exit(FindStart);
end;
end;
cnt := cnt - 1;
if cnt < 1 then begin
DisplayUpdate(wp);
cnt := 1024;
HandleCancelErrorEvents(0, nil, oe, dummy_reply);
if oe <> noErr then begin
FindStart := oe;
exit(FindStart);
end;
end;
until (b = startchar) or (b = ord(':'));
if (b = startchar) and (buffer_len >= buffer_pos + slen) then begin
i := 2;
while (buffer[buffer_pos + i - 2] = ord(startstr[i])) and (i < slen) do begin
i := i + 1;
end;
if i = slen then begin
buffer_pos := buffer_pos + i - 2;
oe := FileReadByte(b);
while (oe = noErr) and (b >= spc) do
oe := FileReadByte(b);
while (oe = noErr) and (b <= spc) do
oe := FileReadByte(b);
if (oe <> noErr) or (b = ord(':')) then begin
FindStart := oe;
exit(FindStart);
end;
end
end
else if not prefs.demand_thisfile_state and (buffer_len >= buffer_pos + 64) then
if (b = ord(':')) and (buffer[buffer_pos + 63] < spc) then begin
i := 0;
while (thevalue[buffer[buffer_pos + i]] <> dud_byte) and (i < 63) do begin
i := i + 1;
end;
if (i = 63) then begin
FindStart := oe;
exit(FindStart);
end;
end;
end;
FindStart := oe;
end;
function ReadHeader (var hi: hqxInfo; wp: windowPtr): OSErr;
var
oe: OSErr;
b: byte;
hc: integer;
actcrc: integer;
nam: str255;
i: integer;
begin
with hi do begin
ReInitReadHQX;
oe := FindStart(wp);
crc := 0;
if oe = noErr then
oe := ReadString(nam);
if (oe = noErr) and ((length(nam) > 63) or (length(nam) < 1)) then
oe := HqxFormatErr; { certainly not a proper HQX file }
if oe = noErr then begin
name := nam;
if name[1] = '.' then
name[1] := 'Ñ'; { Don't create files with names starting with '.' }
for i := 1 to length(name) do begin
if name[i] = ':' then
name[i] := '-';
end;
end;
if oe = noErr then
oe := ReadByte(b);
if (oe = noErr) and (b <> 0) then
oe := HqxFormatErr;
if oe = noErr then
oe := ReadOSType(t);
if oe = noErr then
oe := ReadOSType(c);
if oe = noErr then
oe := ReadInteger(flags);
if oe = noErr then
oe := ReadLong(dlen);
if oe = noErr then
oe := ReadLong(rlen);
if oe = noErr then begin
CalcCRC(crc, 0);
CalcCRC(crc, 0);
actcrc := crc;
oe := ReadInteger(hc);
if (actcrc <> hc) and (oe = noErr) then
oe := HqxFormatErr;
end;
end;
ReadHeader := oe;
end;
end.
